home *** CD-ROM | disk | FTP | other *** search
/ Language/OS - Multiplatform Resource Library / LANGUAGE OS.iso / lisp / clue.lha / clue / defcontact.l < prev    next >
Lisp/Scheme  |  1989-07-12  |  16KB  |  417 lines
  1. ;;; -*- Mode:Lisp; Package:CLUEI; Syntax:COMMON-LISP; Base:10; Lowercase:T -*-
  2.  
  3. ;;;
  4. ;;;             TEXAS INSTRUMENTS INCORPORATED
  5. ;;;                  P.O. BOX 2909
  6. ;;;                   AUSTIN, TEXAS 78769
  7. ;;;
  8. ;;; Copyright (C) 1987 Texas Instruments Incorporated.
  9. ;;;
  10. ;;; Permission is granted to any individual or institution to use, copy, modify,
  11. ;;; and distribute this software, provided that this complete copyright and
  12. ;;; permission notice is maintained, intact, in all copies and supporting
  13. ;;; documentation.
  14. ;;;
  15. ;;; Texas Instruments Incorporated provides this software "as is" without
  16. ;;; express or implied warranty.
  17. ;;;
  18.  
  19. ;;-----------------------------------------------------------------------------
  20. ;;;
  21. ;;; A CLUE contact is a CLOS class that provides default, input and
  22. ;;; geometry (window placement) management services.
  23. ;;;
  24. ;;-----------------------------------------------------------------------------
  25.  
  26. (in-package 'cluei :use '(lisp xlib clos))
  27.  
  28. (export '(
  29.       defcontact      
  30.       )
  31.     'cluei)
  32.  
  33. (proclaim '(inline class-name-of))
  34. (defun class-name-of (instance)
  35.   (class-name (class-of instance)))
  36.  
  37. #+comment ;; This doesn't work because it requires XLIB:WINDOW to have a CLUE meta-class.
  38. (defclass clue (standard-class)
  39.   ((resources :type list :initform nil :initarg :resources :reader clue-resources)
  40.    (resource-options-function :initarg :options-function :reader clue-options-function)))
  41.  
  42. (defmacro clue-resources (class-name)
  43.   `(get ,class-name 'resources)
  44.   #+comment ;; this code when meta-classes are used
  45.   (let ((class (find-class parent)))
  46.     (when (typep class 'clue)
  47.       (clue-resources class))))
  48.  
  49. (defmacro clue-constraints (class-name)
  50.   `(get ,class-name 'constraint-resources))
  51.  
  52. (proclaim '(inline class-all-superclasses))
  53. (defun class-all-superclasses (class)
  54.   "Return the list of all of CLASS's superclasses"
  55.   (get class 'parent-classes))
  56.  
  57. (defsetf class-all-superclasses (class) (list)
  58.   `(setf (get ,class 'parent-classes) ,list))
  59.  
  60.  
  61. ;;; Contacts are CLOS classes whose slots and non-slot initialization
  62. ;;; options may be initialized from the resource databse.  This is done
  63. ;;; as follows:
  64. ;;; slots:    A slot that is also a resource has its :initform 
  65. ;;;           altered so that a resource value can be looked up in
  66. ;;;           :after initialize-instance.  If the resource isn't found, 
  67. ;;;           the result of evaluating, then the original slot :initform is used.
  68. ;;;          :slot for a slot resource is the slot name symbol
  69. ;;;
  70. ;;; non-slot: A resource with no associated slot has :slot NIL.  If a sub-class
  71. ;;;           defines a slot with the same name as a super-class's
  72. ;;;           non-slot resource, the resources continues to be supported
  73. ;;;           as a non-slot resource.  The slot will be initialized
  74. ;;;           through the init-plist.
  75.  
  76.  
  77. (defmacro defcontact (class superclass-names variables &rest options)
  78.   "Defines a contact CLASS."
  79.  
  80.   (let (resources documentation constraints)
  81.     ;; Normalize slot variables
  82.     (setq variables
  83.       (mapcar #'(lambda (r) (if (consp r) r (list r))) variables))
  84.     
  85.     ;; Collect options
  86.     (dolist (option options)
  87.       (ecase (car option)
  88.     (:constraints
  89.      (setf constraints (mapcar #'(lambda (r) (if (consp r) r (list r))) (cdr option))))    
  90.     (:resources
  91.      (setf resources   (mapcar #'(lambda (r) (if (consp r) r (list r))) (cdr option))))     
  92.     (:documentation
  93.      (setf documentation (second option)))))
  94.  
  95.     ;; Fill in options
  96.     (setf constraints
  97.       (define-constraints class superclass-names constraints))
  98.     (setf resources
  99.       (define-contact-resources class superclass-names variables resources))
  100.     (setf variables 
  101.       (mapcar
  102.         #'(lambda (var)
  103.         ;; Fill in :initform and :initarg for slot resources
  104.         (let* ((name     (intern (symbol-name (car var)) 'keyword))               
  105.                (initarg  (getf (cdr var) :initarg))
  106.                (type     (getf (cdr var) :type))               
  107.                (resource (assoc name resources :test #'eq)))
  108.           
  109.           (when resource
  110.             (unless initarg              
  111.               ;; Variables that show up in the resources list need :initarg's
  112.               (setf var `(,@var :initarg ,(or initarg name))))
  113.             
  114.             ;; Save slot :initform in resource spec, if necessary.
  115.             (unless (getf (cdr resource) :initform)
  116.               (setf (getf (cdr resource) :initform)
  117.                 (getf (cdr var) :initform)))
  118.             
  119.             ;; Set the slot :initform to nil so that resource values from the
  120.             ;; database will supersede (see define-initialize-resource-slots)            
  121.             (setf (getf (cdr var) :initform) nil)
  122.             
  123.             (when type
  124.               ;; Adjust type so that nil :initform is valid
  125.               (setf (getf (cdr var) :type) `(or null ,type)))))
  126.         var)
  127.         variables))
  128.     `(progn
  129.        (eval-when (compile load eval)
  130.      (setf (class-all-superclasses ',class)
  131.            ',(delete-duplicates
  132.            (apply #'append
  133.               superclass-names
  134.               (mapcar #'class-all-superclasses superclass-names))
  135.            :test #'eq))
  136.      (setf (clue-resources ',class)   ',resources
  137.            (clue-constraints ',class) ',constraints))
  138.        (defclass ,class ,superclass-names
  139.      ,variables
  140.      #+comment ;; this code when meta-classes are used
  141.      (:metaclass clue)
  142.      #+comment ;; this code when meta-classes are used
  143.      (:resources ,@(def-contact-resources class superclass-names variables resources))
  144.      ,@(when documentation `((:documentation ,documentation))))
  145.        ,(define-clue-default-options class resources)
  146.        ,(define-initialize-resource-slots class resources)
  147.        ,(define-initialize-constraints class constraints)
  148.        ',class)))
  149.  
  150. (proclaim '(special *resources* *parent*))
  151.  
  152. (defmacro lookup-resource (class resource-name)
  153.   ;; Lookup and type-check/convert resource-name for class
  154.   (let* ((value (gensym)))
  155.     `(let ((,value ,(find-resource class resource-name (clue-resources class) '*resources*)))
  156.        ,(convert-resource class resource-name value (clue-resources class) '*parent*))))
  157.  
  158. (defun find-resource (class resource-name resources resource-table)
  159.   "Generate code to lookup resource-name for class, and return it or its default value."
  160.   (let* ((name (intern (string resource-name) :keyword))
  161.      (resource (assoc name (or resources (clue-resources class)))))
  162.     (unless (pop resource) (error "~a isn't a resource of the ~s class" resource-name class))
  163.     (let ((class (getf resource :class))
  164.       (init (getf resource :initform)))
  165.       `(or (get-search-resource ,resource-table ',name ',class) ,init))))
  166.  
  167. (defun convert-resource (class resource-name value resources parent)
  168.   ;; Generate code to do type checking and conversion on value for resource-name of class
  169.   (let* ((name (intern (string resource-name) :keyword))
  170.      (resource (assoc name (or resources (clue-resources class)))))
  171.     (unless (pop resource) (error "~a isn't a resource of the ~s class" resource-name class))
  172.     (let ((type (getf resource :type)))
  173.       (if type
  174.       `(if (typep ,value ',type)
  175.            ,value
  176.            (do-convert ,parent ,value ',type))
  177.       value))))
  178.  
  179. (defun do-convert (parent value type)
  180.   (let ((converted-value (convert parent value type)))
  181.     ;; Boolean conversion may convert a non-nil value to nil, and that's OK.
  182.     (when (and (null converted-value)
  183.            (not (typep converted-value type)))
  184.       (xlib::x-type-error value type))
  185.     converted-value))
  186.  
  187. (defun define-contact-resources (class superclass-names variables resource-list)
  188.   "Construct and validate the resource list for CLASS.  A :slot option is added to
  189. each resource specification containing the resource slot name, if any."
  190.   (do* (name
  191.     (resources resource-list (cdr resources))
  192.     (resource (car resources) (car resources))
  193.     
  194.     ;; Initialize result with all inherited resources
  195.     (result (mapcan #'(lambda (parent)
  196.                 (copy-list
  197.                   (clue-resources parent)
  198.                   #+comment ;; this code when meta-classes are used
  199.                   (let ((class (find-class parent)))
  200.                 (when (typep class 'clue)
  201.                   (clue-resources class)))))
  202.             superclass-names)))
  203.        ((endp resources)
  204.     (reconcile-contact-resource-with-slots variables result))
  205.     ;;
  206.     ;; Make name and class keywords
  207.     (let ((class (getf (cdr resource) :class)))
  208.       (setf name (intern (string (car resource)) 'keyword)
  209.         (car resource) name)
  210.       (when class
  211.     (setf (getf (cdr resource) :class) (intern (string class) 'keyword))))
  212.     ;;
  213.     ;; Merge resource with parent's resource
  214.     (do* ((inherited-resource (cdr (assoc name result :test #'eq)))
  215.       (old inherited-resource (cddr old)))
  216.      ((endp old))
  217.       (unless (getf (cdr resource) (car old))
  218.     (setq resource (append resource `(,(car old) ,(cadr old))))))
  219.     ;;
  220.     ;; Error checking
  221.     (do ((key (cdr resource) (cddr key)))
  222.     ((endp key))
  223.       (unless (member (car key) '(:initform :type :class :documentation :slot :remove))
  224.     (error "~s is an unknown option for resource ~s in ~s" (car key) (car resource) class)))
  225.     (setq result (delete name result :key #'car :test #'eq))
  226.     (unless (getf (cdr resource) :remove)
  227.       (push resource result))))
  228.  
  229.  
  230. (defun define-constraints (class superclass-names resource-list)
  231.   "Construct and validate the constraint resource list for CLASS."
  232.   (do* (name
  233.     (resources resource-list (cdr resources))
  234.     (resource (car resources) (car resources))
  235.     
  236.     ;; Initialize result with all inherited resources
  237.     (result (mapcan #'(lambda (parent)
  238.                 (copy-list
  239.                   (clue-constraints parent)))
  240.             superclass-names)))
  241.        ((endp resources) result)
  242.     ;;
  243.     ;; Make name and class keywords
  244.     (let ((class (getf (cdr resource) :class)))
  245.       (setf name (intern (string (car resource)) 'keyword)
  246.         (car resource) name)
  247.       (when class
  248.     (setf (getf (cdr resource) :class) (intern (string class) 'keyword))))
  249.     ;;
  250.     ;; Merge resource with parent's resource
  251.     (do* ((inherited-resource (cdr (assoc name result :test #'eq)))
  252.       (old inherited-resource (cddr old)))
  253.      ((endp old))
  254.       (unless (getf (cdr resource) (car old))
  255.     (setq resource (append resource `(,(car old) ,(cadr old))))))
  256.     ;;
  257.     ;; Error checking
  258.     (do ((key (cdr resource) (cddr key)))
  259.     ((endp key))
  260.       (unless (member (car key) '(:initform :type :class :documentation))
  261.     (error "~s is an unknown option for constraint ~s in ~s" (car key) (car resource) class)))
  262.     (setq result (delete name result :key #'car :test #'eq))
  263.     (push resource result)))
  264.  
  265.  
  266. (defun reconcile-contact-resource-with-slots (variables resource-list)
  267.   "Reconcile resource and slot types and mark slot/non-slot resources."
  268.   (do* ((resources resource-list (cdr resources))
  269.     (resource (car resources) (car resources))
  270.     (name (car resource) (car resource)))
  271.        ((endp resources) resource-list)
  272.     
  273.     (let ((entry (assoc (symbol-name name) variables :key #'symbol-name :test #'equal)))
  274.       (if entry
  275.       ;; Slot resource 
  276.       (let ((slot-type (getf (cdr entry) :type))
  277.         (slot-initform (getf (cdr entry) :initform)))
  278.  
  279.         ;; Reconcile slot/resource type
  280.         (when slot-type
  281.           (let ((resource-type (getf (cdr resource) :type)))
  282.         (if resource-type
  283.             (unless (or (equal resource-type slot-type)
  284.                 (subtypep resource-type slot-type))
  285.               (error "~s is incompatibly typed as ~s in slot and ~s in the resources"
  286.                  name slot-type resource-type))
  287.             (setq resource (nconc resource `(:type ,slot-type))))))
  288.  
  289.         ;; Initialize :slot option
  290.         (when (eq (getf (cdr resource) :slot 'undefined) 'undefined)
  291.           (setq resource (nconc resource (list* :slot (car entry) nil))))
  292.  
  293.         ;; Initialize :initform option
  294.         (when slot-initform
  295.           (setf (getf (cdr resource) :initform) slot-initform)))
  296.       
  297.       ;; Mark non-slot resources with a NIL :slot value
  298.       (when (eq (getf (cdr resource) :slot 'undefined) 'undefined)
  299.         (setq resource (nconc resource '(:slot nil))))))))
  300.  
  301. (defun define-initialize-resource-slots (contact-class resources)
  302.   "Define the initialize-resource-slots method for CONTACT-CLASS."
  303.   (let ((code nil) slot)
  304.     `(defmethod initialize-resource-slots ((instance ,contact-class) resource-table app-defaults)
  305.        
  306.        ;; Check resource types and fill in defaults.
  307.        ;; Assumes the :initform for all resource slots NIL (the true initform is evaluated here).       
  308.        (let ((parent (slot-value (the ,contact-class instance) 'parent)))
  309.      
  310.      ;; NOTE: PARENT is null when contact-class is ROOT.
  311.      ;; This may lose for some root resources requiring conversion.
  312.      ,@(dolist (resource resources code)
  313.          (when (setq slot (getf (cdr resource) :slot))
  314.            (push
  315.          (set-resource-slot (car resource) resources slot)
  316.          code)))))))
  317.  
  318. (defun define-initialize-constraints (composite-class constraints)
  319.   "Define the initialize-constraints method for COMPOSITE-CLASS."
  320.   (when constraints
  321.     (let (code)
  322.       `(defmethod initialize-constraints ((parent ,composite-class) initargs resource-table)
  323.      (let (options (app-defaults (getf initargs :defaults)))
  324.        
  325.        ;; Generate code to find constraint values, convert to representation type,
  326.        ;; and add to option list
  327.        ,@(dolist (constraint constraints code)
  328.            (push
  329.          (push-constraint (car constraint) constraints)
  330.          code))
  331.        options)))))
  332.  
  333. (defmethod initialize-constraints (parent initargs resource-table)
  334.   (declare (ignore parent initargs resource-table))
  335.   ;; Default primary method for class with no constraints -- nothing happens!
  336.   nil)
  337.  
  338. (defun define-clue-default-options (contact-class resources)
  339.   "Defines the default-options method that defaults non-slot resources for CONTACT-CLASS."
  340.   (let (code) 
  341.     `(defmethod default-options ((class (eql ',contact-class)) initargs)       
  342.        (let ((options      (copy-list initargs))
  343.          (app-defaults (getf initargs :defaults))
  344.          (parent       (getf initargs :parent)))
  345.  
  346.      ;; "Use" app-defaults to avoid compiler warning when no non-slot resources exist.
  347.      app-defaults
  348.      
  349.      ;; Convert parent arg, if necessary
  350.      (when (display-p parent)      
  351.        (setf options (list* :parent
  352.                 (setf parent (display-root parent (getf initargs :screen)))
  353.                 options)))
  354.  
  355.      ;; Build a resource table for fast resource lookup
  356.      (let ((resource-table (get-contact-resource-table class parent initargs)))
  357.        
  358.        ;; Generate code to find resource values, convert to representation type,
  359.        ;; and add to option list
  360.        ,@(dolist (resource resources code)
  361.            (unless (getf (cdr resource) :slot 'undefined)
  362.          (push
  363.            (push-resource (car resource) resources)
  364.            code)))
  365.        (list* :resource-table resource-table options))))))
  366.  
  367.  
  368. (defun push-resource (name resources)
  369.   "Generate code to find resource value, convert to representation type, and add to option list."
  370.   (let ((resource (rest (assoc name resources))))    
  371.     (let ((type (getf resource :type)))
  372.       `(let* ((initarg-p (getf initargs ,name))
  373.           (value     (or  initarg-p
  374.                   (get-search-resource resource-table ,name ,(getf resource :class))
  375.                   (getf app-defaults ,name)
  376.                   ,(getf resource :initform)))
  377.           (no-convert-p ,(if type `(and value (typep value ',type)) t)))
  378.      (and value
  379.         (not (and initarg-p no-convert-p))
  380.         (setf options
  381.               (list* ',name
  382.                  (if no-convert-p
  383.                  value
  384.                  ,(when type `(do-convert parent value ',type)))
  385.                  options)))))))
  386.  
  387.  
  388. (defun push-constraint (name constraints)
  389.   "Generate code to find constraint value, convert to representation type, and add to option list."
  390.   (let ((constraint (rest (assoc name constraints))))    
  391.     (let ((type (getf constraint :type)))
  392.       `(let* ((value     (or  (getf initargs ,name)
  393.                   (get-search-resource resource-table ,name ,(getf constraint :class))
  394.                   (getf app-defaults ,name)
  395.                   ,(getf constraint :initform))))
  396.      (when value       
  397.        (setf options
  398.          (list* ',name
  399.             ,(if type
  400.                  `(do-convert parent value ',type)
  401.                  'value)                 
  402.             options)))))))
  403.  
  404.  
  405. (defun set-resource-slot (name resources slot)
  406.   "Generate code to find resource value, convert to representation type, and set corresponding slot."  
  407.   (let ((resource (rest (assoc name resources))))    
  408.     (let ((type (getf resource :type)))
  409.       `(let* ((value     (or  (slot-value instance ',slot)
  410.                   (get-search-resource resource-table ,name ,(getf resource :class))
  411.                   (getf app-defaults ,name)
  412.                   ,(getf resource :initform))))
  413.      (when value       
  414.        (setf (slot-value instance ',slot)
  415.          ,(if type
  416.               `(do-convert parent value ',type)
  417.               'value)))))))